
;code for folded power transformations (c) Pedro Valero 1999

(provide "folded-power")

;Sets menu item

(defproto Folded-Power-transf-object-proto 
  '(tool data fp-data title name  dialog variables transf-data values-list) () transf-object-proto)

(defmeth Folded-Power-transf-object-proto :transf-data 
  (&optional (values nil set))
  "Transformed data"
  (if set (setf (slot-value 'transf-data) values)      
  (slot-value 'transf-data)))

(defmeth Folded-Power-transf-object-proto :values-list
  (&optional (values nil set))
  "Transformed data"
  (if set (setf (slot-value 'values-list) values)      
  (slot-value 'values-list)))

(defmeth Folded-Power-transf-object-proto :fp-data
  (&optional (values nil set))
  (if set (setf (slot-value 'fp-data) values)      
  (slot-value 'fp-data)))

(defun Folded-Power-transf
  (&key 
   (id-data      current-data)
   (dialog     nil)
   (name       "Folded Power")
   (variables  (send current-data :active-variables '(numeric)))
   (title      "Folded Power Transformations")
   (transf-data (send current-data :active-data-matrix '(numeric)))
   
   )

  
      (if (> (length variables) 10) 
          (error-message "Ten variables is the maximum for this command")
          (send Folded-Power-transf-object-proto :new 9 id-data title name dialog variables transf-data ))

  
  )

(defmeth Folded-Power-transf-object-proto :isnew (&rest args)
  (setf data-transf-out nil)
  (apply #'call-next-method (select args (list 0 1 2 3 4)))
  (setf data-transf-out 
        (data (send self :name)          
              :created  (send *desktop* :selected-icon)          
              :title     (concatenate 'string "FP-"(send self :title))
              :variables (sixth args )  
              :data      (combine 
                          (transpose 
                           (map-elements 'coerce 
                                         (mapcar #'(lambda (var)
                                                     (function-with-missing                                                   #'folded-power var (list 1.01)))
                                                 (column-list (seventh args)))

                                                 'list)))
              :labels    (send (second args) :active-labels)
              :types     (send (second args) :active-types '(numeric))))

  (defmeth data-transf-out :update-from-spreadplot (i j args)
    (let* (
          (data-t (column-list (send self :data-matrix)))
          (variable-selected (first args))
          (data (second args))
          (values-list (third args))
          (variables (fourth args))
          )
      (setf (select data-t variable-selected) 
            (list 
             (function-with-missing #'folded-power
                                    (first 
                                     (select data 
                                             variable-selected))
                                   (select values-list variable-selected) )))
      
      (when (send self :datasheet-open)
            (send (send self :datasheet-object) :close))
      
      (send self :variables 
            (map-elements 'concatenate 'string 
                          variables
                          "_p_" 
                          (mapcar #'(lambda (val) (format nil "~,2g" val))
                                           values-list)))
      

     (send self :data 
            (combine (transpose (map-elements 'coerce data-t 'list))))     
      (send self :datasheet-object nil)
      ))

  ;fwy 092599 - added following statement
 #+containers (send self :tmat-menu-item)
 
  )

(defmeth Folded-Power-transf-object-proto :options () t)


(defun folded-power (x p)
  "Args:x variable to be transformed. P value for the transformations. Some interesting values of p are:
1  plurality
0.5 folded root square
0.41 Arcsin
0.14 Probit
0 Logit"
    (cond 
      ((or (<  (min x) 0)
           (>  (max x) 1))
       x) ;if the data are not valid it just returns the original values
      ((and (< 0 (min x) )
            (> 1 (max x) )
            (= p 0))
       (/ (log (/ x (- 1 x))) 2))
      ((and (or (= (min x) 0)
                (= (max x) 1)
                )
            (<= p 0))
       (/ (- (^ (* 2 x) 0.01) 
             (^ (- 2 (* 2 x)) 0.01)) 
          (* 2 0.01)));if the data contains 1 or 0 p is equal to 0.01
      ((<= p 0) (log (- (log (- 1 x))))) ;values of p equal to zero will return this when there are values of 0 or 1 in the original data
      ((> p 1) x) ;values of p above 1 return the original variable
      (t (/ (- (^ (* 2 x) p) (^ (- 2 (* 2 x)) p)) (* 2 p)))))
 

(defmeth Folded-Power-transf-object-proto :analysis ()
  (setf ct (make-container :free t :type 5 :local-menus t :show nil))
		(enable-container ct)
	(setf *spreadplot-container ct)
  (let* (
	(vars (send self :variables))
         (fp-object self)
         (column-data (column-list (send self :active-data-matrix '(numeric))))
         (lista-labels (name-list (send self :active-labels) 
                                  :title "Labels" :show nil))
         (check-valid-variables 
          (mapcar #'(lambda (variable)  
                      (or (< (min (non-missing variable)) 0) 
                          (> (max (non-missing variable)) 1))) column-data))
         (no-valid-variables  (which check-valid-variables))
         (valid-variables (which (mapcar #'null check-valid-variables)))
         (lista-vars 
          (name-list (send self :variables) 
                     :title "Variables" :show nil)) ; The list of names of variables
         (sct-matrix (cond
                       ((> (length (send self :variables)) 2)
                        (scatterplot-matrix 
                         (mapcar #'(lambda (var)
                                     (function-with-missing #'folded-power var (list 1.01)))
                                 column-data)
                         :show nil)) 
                       ((equal (length (send self :variables)) 2)
                        (plot-points (mapcar #'(lambda (var)
                                                 (function-with-missing 
                                                  #'folded-power var (list 1.01)))
                                             column-data)
                                     :show nil))
                       (t (qplot (function-with-missing 
                                  #'folded-power (first column-data) (list 1.01)):show nil))
                       ))
         (plot-power (if valid-variables
                         (plot-lines 
                          (rseq 
                           (min (non-missing (select column-data (first valid-variables)))) 
                           (max (non-missing (select column-data (first valid-variables)))) 200)
                          (folded-power  
                             (rseq 
                              (min (non-missing (select column-data (first valid-variables))))
                              (max (non-missing (select column-data (first valid-variables))))
                              200) 
				1.01) 
                          :title "Shape of the transformation"
                          :show nil)
                         (error-message "No valid variables for folded-power transformation. Only variables with values between 0 and 1 are appropriate for these transformations")))
         (histogram-Folded-Power 
          (histogram (select column-data (first valid-variables))
                     :variable-labels (select (send self :variables) (first valid-variables)) :show nil)) ;the histogram
         
         (slider 
          (interval-slider-dialog 
           (list -.01 1.01)                                       
           :points 100           
           :nice t
           :action #'(lambda (p)      
                   (when (send lista-vars :selection)
                       (send matrix-transf :update-spreadplot 1 0 :args p )))))
         (matrix-transf nil) 

         )
	(send self :fp-data column-data)
	(send self :transf-data column-data)
    (when no-valid-variables (send lista-vars :point-state no-valid-variables 'invisible))

    (send self :values-list (repeat 1.01 (length column-data)))

    ;This is a list of ones for initial values of the slider
    
   (send lista-vars :selection (list (first  valid-variables))) ; this initializes the namelist to the first element
  


    (send lista-labels :title "Observations")
    (send lista-labels :new-menu "Obs" 
          :items '(LINK MOUSE DASH ERASE-SELECTION FOCUS-ON-SELECTION 
                        SHOW-ALL COLOR SELECTION))
    (send lista-labels :fix-name-list)
    (send lista-labels :use-color t)
    (send lista-labels :point-color (iseq (send lista-labels :num-points)) 'blue)


    ;acerca del gráfico de potencia de la transformacion

    (send plot-power 
          :plot-buttons 
          :margin (list 0 17 0 0) 
          :new-x nil 
          :new-y nil 
          :mouse-mode t)
    (send plot-power :use-color t)
    (defmeth plot-power :plot-help ()
      (plot-help-window (strcat "Help for " (send self :title)))
      (paste-plot-help 
       (format nil "This plot shows the shape of the transformation applied to the variable selected. The family of transformations here applied are basically linear in the centre of the distribution but folds data in the ties. Some (statistically) interesting values of the slider are:
1 : plurality
0.5 folded root square
0.41 Arcsin
0.14 Probit
0 Logit ~2%"))
      (show-plot-help))
(send plot-power :title (strcat "Transformation of " (select vars 
	(first valid-variables))))
;acerca del histograma

    (send histogram-Folded-Power 
          :plot-buttons 
          :margin (list 0 17 0 0) 
          :bottom-tool-bar t
          :curves t
          :new-x nil
          :new-y nil 
          :mouse-mode t)
    (send histogram-Folded-Power :use-color t)
    (defmeth histogram-Folded-Power :plot-help ()
      (plot-help-window (strcat "Help for " (send self :title)))
      (paste-plot-help (format nil "This histogram shows the shape of the data after aplying the transformation corresponding to the value of the slider. You usually look for a symetric shape.~2%"))
      (show-plot-help))
     (send histogram-folded-power :point-color (iseq (send sct-matrix :num-points)) 'blue)
  	(send histogram-folded-power :title (strcat "Histogram of " (select vars (first valid-variables))))
  
    

    
;matriz de diagramas de dispersión
     
      
       
       (send sct-matrix 
             :variable-label (iseq (length column-data))
             (send self :variables))
       (send sct-matrix 
            :plot-buttons 
             :margin (list 0 17 0 0) 
             :new-x nil 
             :new-y nil 
             :mouse-mode t)
       (send sct-matrix :use-color t)
      
;======================================================
;fwy 090699
;following sct-matrix statements added by forrest young
;they add variable-focus method and color

    ;(send sct-matrix :linked t) removed PV
    (send sct-matrix :use-color t)
    (send sct-matrix :point-color (iseq (send sct-matrix :num-points)) 'blue)
    (send sct-matrix :add-mouse-mode 'focus-on-variables
          :title "Focus On Variables"
          :click :do-new-variable-focus
          :cursor 'finger)
    (send sct-matrix :plot-buttons :new-x nil :new-y nil)
    (send sct-matrix :mouse-mode 'focus-on-variables)
    (defmeth sct-matrix :do-new-variable-focus (x y m1 m2) 
 ; (print (send self :current-variables))   
      (send matrix-transf :update-spreadplot 0 4 
            :args (list (first (send self :current-variables)))));notice the value in colum PV
;======================================================

  (defmeth sct-matrix :plot-help ()
    (plot-help-window (strcat "Help for " (send self :title)))
    (paste-plot-help (format nil "The Power folded transformations can improve the shape of the relationships between variables which are proportion and others which are continuous by making them more linear. This happens because variables which are proportions are limited on the extremes. The power folded transformations stretches the ties of the variables, allowing that relationships on the extremes arise more linear. ~2%"))
    (show-plot-help))

    ;esto es para evitar el error de no hacer ningun cambio en los datos
  
  (setf matrix-transf (spread-plot (matrix (list 2 3) 
                                           (list lista-labels
						 sct-matrix  
                                                 histogram-Folded-Power 
                                                 lista-vars 
                                                 nil 
                                                 plot-power 
                                                 )) 

			:container ct 
			:supplemental-plot slider
			:show t
			:rel-widths (list .5 2 1)
           		:span-down (matrix (list 2 3) (list 1 2 1 1 0 1))))
    

(defmeth matrix-transf :spreadplot-help ()
      (plot-help-window (strcat "Spreadplot Help"))
      (paste-plot-help (format nil "This spreadplot is designed to compute Power Folded transformations. These transformations are appropriate for data which are proportions. This command considers all the variables between 0 and 1 as proportions, and the rest as continuous variables. The data so regarded as proportions will be transformed first using the value in the slider equal to one. Using the slider you can apply other transformations which include some of the most interesting transformations for proportions. Some interesting values of the slider are:
1 : plurality
0.5 : folded root square
0.41 : Arcsin
0.14 : Probit
0 : Logit
Using the slider the variable currently selected will be transformed aplying one of a set of functions. You usually look for a symmetric histogram and linear relationships with the data of interest in the matrix of scatterplots."))
      (show-plot-help))
    
  

  (defmeth matrix-transf :update-spreadplot (i j &rest args &key (tell-statobjct nil))
    (let* 
      (
         
       (row i)
       (column j)
       (variable-selected (send lista-vars :selection))

       (tell-statobjct tell-statobjct)
       (values-list (send fp-object :values-list))
       (data (column-list (send fp-object :active-data-matrix '(numeric))))
       )
	
        (cond
          
           ((and (equal row 1) (equal column 0)) 
            (when (or (< (min (non-missing (first (select data variable-selected)))) 0)
                      (> (max (non-missing (first (select data variable-selected)))) 1))
                    (error-message "Warning: This variable contain values out of range (0-1). Lambda-Tukey transformation is not apropriate in this case and will not be applied. 
Do not touch the slider or you will run into problems!")
                    )
            
                   (setf (select (send fp-object :values-list) variable-selected) (second args))
           
                      (setf values-list (send fp-object :values-list))         
                      (cond 
                        (data-transf-out
                         (send data-transf-out :update-from-spreadplot 
                               row column (list variable-selected data values-list 
                                                (send fp-object :variables)))
                         (send histogram-Folded-Power :update-plotcell row column 
                               (select (column-list (send data-transf-out :data-matrix))
                                       variable-selected)
                               (first (select vars variable-selected)))
            
                         (send sct-matrix :update-plotcell row column 
                               (send data-transf-out :data-matrix))
                         (send plot-power :update-plotcell row column 
                 		 (select data variable-selected)
                  		(select values-list variable-selected)
                 		 (first (select vars variable-selected)))
                         ))
            )
          ((and (equal row 0 ) (equal column 1))
           (send sct-matrix :update-plotcell row column (first args) (second args))
           (send lista-labels :update-plotcell row column (first args) (second args))
	)
	((and (equal row 0 ) (equal column 4))
	  	;(send lista-vars :unselect-all-points)                     
		(setf variable-selected (second args))
		(send histogram-Folded-Power :update-plotcell row column 
     	 		(select (column-list (send data-transf-out :data-matrix))
            	  		variable-selected)
     			 (first (select vars variable-selected)))
            
		(send plot-power :update-plotcell row column 
   			 (select data variable-selected)
    				(select values-list variable-selected)
   				 (first (select vars variable-selected)))
           )
          ((and (equal row 1 ) (equal column 2))
           
           (send sct-matrix :update-plotcell row column (first args) (second args))
           (send histogram-Folded-Power :update-plotcell row column 
							(first args) 
							(second args)
							)
           )
          ((and (equal row 0 ) (equal column 0))
                     (send histogram-Folded-Power :update-plotcell row column 
							(first args) 
							(second args)
							)
           (send lista-labels :update-plotcell row column (first args) (second args))
           )
          ((and (equal row 0 ) (equal column 2))

          	 (setf values-list (send fp-object :values-list))
           	(send slider :update-plotcell row column
                 	 (select values-list variable-selected)) ;sets the value in the slider
           
           )

          (t (send histogram-Folded-Power :update-plotcell row column 
                 (append (select (column-list (send data-transf-out :data-matrix))
                                                            variable-selected)) 
		(third args))
              (send sct-matrix :update-plotcell row column (send data-transf-out :data-matrix))
              (send plot-power :update-plotcell row column 
                                                      (select data variable-selected)
                                                      (select values-list variable-selected))
             )))
        )
    
    (defmeth histogram-Folded-Power :do-click (a b c d)
      (call-next-method a b c d)
      (send matrix-transf :update-spreadplot 0 1 (send self :selection) 
            (send self :point-color (iseq 0 (1- (send self :num-points)))))
      )
    (defmeth histogram-Folded-Power :set-selection-color ()
      (call-next-method)      
      (send matrix-transf :update-spreadplot 0 1 (send self :selection) 
            (send self :point-color (iseq 0 (1- (send self :num-points)))))
      )
    (defmeth sct-matrix :do-click (a b c d)
      (call-next-method a b c d)
      (send matrix-transf :update-spreadplot 0 0 (send self :selection) 
            (send self :point-color (iseq 0 (1- (send self :num-points)))))
      ) 
    (defmeth sct-matrix :set-selection-color ()
      (call-next-method)      
      (send matrix-transf :update-spreadplot 0 0 (send self :selection) 
            (send self :point-color (iseq 0 (1- (send self :num-points)))))
      )
    (defmeth lista-labels :do-click (a b c d)
      (call-next-method a b c d)
      (send matrix-transf :update-spreadplot 1 2 (send self :selection) 
            (send self :point-color (iseq 0 (1- (send self :num-points)))))
      )
    
    (defmeth lista-labels :set-selection-color ()
      (call-next-method)      
      
      (send matrix-transf :update-spreadplot 1 2 (send self :selection) 
            (send self :point-color (iseq 0 (1- (send self :num-points)))))
      )
    
    (defmeth lista-vars :do-click  (x y z w)   
      (call-next-method x y z w)        
     (when (send self :selection) (send matrix-transf :update-spreadplot 0 2 
            :args (send self :selection )))
      )
      
    (defmeth slider :update-plotcell (i j &rest args)
      
      (send self :value (first (first args)))
      )

 (defmeth slider :update-from-spreadplot 
        (i j &rest args)
        (let
          (      
           (variable-selected (first args))
           (data (second args))
           (data-transf (third args))         
           (values-list (fourth args))
           )
          (send matrix-transf :transf-data data-transf)
          (setf (select values-list variable-selected) 
                (/ (round (* 10 (send self :value)))
                   10)) ;sets the value in the slider  
          (send matrix-transf :update-spreadplot 
                1 0  variable-selected data values-list) 
                 ))
    
  (defmeth histogram-Folded-Power :update-plotcell (i j &rest args)
        (let (
              (row i)
              (column j)
              (variable nil)
              (selection nil)
              (args args)
              (color nil)
              )
         (cond 
           ((or (and (equal row 1) (equal column 0)) (and (equal row 0) (equal column 4)))
            (send self :title (strcat "Histogram of " (second args)))
           (setf variable (first (first args)))
            (setf selection (send self :selection))
            (setf color (send self :point-color (iseq (send self :num-points))))
            (send self :clear )
            (send self :add-points variable :draw nil)
            (send self :selection selection)
            (send self :point-color (iseq (send self :num-points)) color)
            (send self :adjust-to-data)
            (send self :redraw)
            )
           ((or (and (equal row 0) (equal column 0)) (and (equal row 1) (equal column 2)))
            (send self :start-buffering)
            (send self :point-color (iseq (send self :num-points)) (second args))
            (send self :selection (first args))
            (send self :redraw)
            (send self :buffer-to-screen)
            )
	)
	))

  (defmeth plot-power :update-plotcell (i j &rest args)

        (let (
              (row i)
              (column j)
              (variable (first (first args)))
              (p (first (second args)))
              )
          (send self :clear )                                                   
          (send self :add-lines 
                (rseq 
                 (min (non-missing variable))
                 (max (non-missing variable)) 
                 200)

                (function-with-missing 
			#'folded-power  
                 (rseq 
                  (min (non-missing variable))
                  (max (non-missing variable)) 
                  200) ;rsq does not return the max value so folded-power is always computed correctly. This could be used to plot original data agains this line
                 (list p)) 
                :draw nil)

          (send self :adjust-to-data)
	
          (send self :title (strcat "Transformation of " (third args)))
          ))

      (defmeth sct-matrix :update-plotcell (i j &rest args)
        (let* 
          (
           (row i)
           (column j)
           (args args)
           (data-transf nil) 
           (selection nil) 
           (color nil)
           
           )
           
          (cond
            ((and (equal row 1) (equal column 0))
             (send self :start-buffering)
             (setf data-transf (column-list (first args)))
             (setf selection (send self :selection))
             (setf color (send self :point-color (iseq (send self :num-points))))
             (send sct-matrix :clear )
             
             (if 
              (equal (length data-transf) 1)
              (send sct-matrix :new-plot (first data-transf))
              (send sct-matrix :add-points data-transf :draw nil )
              )
             (if (> (length data-transf) 1) (send sct-matrix :adjust-to-data))
             
             (send self :point-color (iseq 0 (1- (send self :num-points))) color)
             (send self :selection selection)
             (send self :redraw)
             (send self :buffer-to-screen))
            ((or (and (equal row 0) (equal column 1)) (and (equal row 1) (equal column 2)))
             (send self :start-buffering)
             (send self :point-color (iseq (send self :num-points)) (second args))
             (send self :selection (first args))
             (send self :redraw)
             (send self :buffer-to-screen)
             ))
             (send fp-object :transf-data data-transf)
          ))
  (defmeth lista-labels :update-plotcell (i j &rest args)
    (let* 
      (
       (row i)
       (column j)
       (args args)
       )
      (send self :selection (first args)) 
      (send self :point-color (iseq (send self :num-points)) (second args))
      
      (send self :use-color t)
      (send self :redraw)
      
      )) 
    (defmeth slider :install-plot-help-item ()) ;it is empty, has to be filled.
    (defmeth slider :remove-plot-help-item ())
    (defmeth slider :redraw ())
    
    (defmeth slider :plot-help ()
      (plot-help-window (strcat "Help for " (send self :title)))
      (paste-plot-help (format nil "This plot shows the power of the transformation applied to the variable selected~2%"))
      (show-plot-help))
    (send matrix-transf :show-spreadplot)
    (send slider :value 1.01)
    (disable-container)
  ))
    
    ;======================================================
;fwy 092599 - added remaining code - requires containers
;======================================================

#+containers
(defmeth Folded-Power-transf-object-proto :tmat-menu-item ()
  (let ((lastitem (first (last (send *spreadplot-window-menu* :items))))
        )
    (send *spreadplot-window-menu* :delete-items lastitem)
    (send *spreadplot-window-menu* :delete-items
          (first (last (send *spreadplot-window-menu* :items))))
    (send *spreadplot-window-menu* :append-items

          (send menu-item-proto :new "Transformation PlotMatrix"
                :action #'(lambda ()(send self :t-scatmat)))
          (send dash-item-proto :new)
          lastitem)))

#+containers
(defmeth Folded-Power-transf-object-proto :t-scatmat ()
  (setf *spreadplot-container* (make-container :size (send *vista* :spreadplot-sizes) 
                                          :free t :local-menus t :type 1 :show nil))
  (let* ((raw-vars (send self :fp-data))
         (trans-vars (send self :transf-data))
         (nvar (length raw-vars))
         (obs-labs (name-list (send self :active-labels) 
                                  :title "Observations" :show nil))
         (plot-vec (matrix (list nvar 1) (combine obs-labs (repeat nil (1- nvar)))))
         (plots)
         (plot-matrix)
         (sp))
    (mapcar #'(lambda (raw-vary trans-vary i)
                (mapcar #'(lambda (raw-varx trans-varx j)
                            (cond 
                              ((< i j)
                               (setf pp (plot-points (list (eval raw-vary) 
                                                           (eval raw-varx)) 
                                                     :show t)))
                              ((= i j)
                               (setf pp (plot-points (list (eval raw-vary) 
                                                           (eval trans-vary)) 
                                                     :show t)))
                              ((> i j)
                               (setf pp (plot-points (list (eval trans-varx) 
                                                           (eval trans-vary))
                                                     :show t))))
                            (send pp :showing-labels nil)
                            (send pp :use-color t)
                            (send pp :point-color (iseq (send pp :num-points)) 'blue)
                            (send pp :mouse-mode 'brushing)
                            (send pp :x-axis nil)
                            (send pp :y-axis nil)
                            (send pp :legend1 " ")
                            (send pp :legend2 " ")
                            (send pp :make-scatterplot-curves) 
                            (send pp :lowess-fraction .5)
                            (send pp :switch-add-linear)
                            (send pp :switch-add-lowess)
                            (setf plots (append plots (list pp))))
                        raw-vars trans-vars (iseq nvar)))
            (reverse raw-vars) (reverse trans-vars) (reverse (iseq nvar)))
    (setf plot-matrix (matrix (list nvar nvar) (combine plots)))
    (setf plots (combine (bind-columns plot-vec plot-matrix)))
    (setf sp (spread-plot (matrix (list nvar (1+ nvar)) plots)
                          :span-down (matrix (list nvar (1+ nvar) )
                                    (combine 5 (repeat 1 nvar)
                                             (repeat (combine 0 (repeat 1 nvar)) 
                                                     (1- nvar))))))
    (mapcar #'(lambda (plot) (when plot (send plot :linked t))) plots)
    (send sp :show-spreadplot)
    (apply #'send *spreadplot-container* :size (send *vista* :spreadplot-sizes))
    (send *spreadplot-container* :show-window) 
    (refresh-spreadplot)
    (disable-container)))
